; $Id: cl-ass.lisp 18 2014-08-05 20:42:21Z admin@en-circle.com $
; Copyright (c) 2014 Peter Vanusanik <admin@en-circle.com>
;
;Permission is hereby granted, free of charge, to any person obtaining a copy
;of this software and associated documentation files (the "Software"), to deal
;in the Software without restriction, including without limitation the rights
;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;copies of the Software, and to permit persons to whom the Software is
;furnished to do so, subject to the following conditions:
;
;The above copyright notice and this permission notice shall be included in
;all copies or substantial portions of the Software.
;
;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
;THE SOFTWARE.

#+quicklisp(ql:quickload "cl-store")
(push :cl-ass *features*)

; Constants
(defparameter *system-classes* '(storable-class agent agent-class environment-class environment simulation-class simulation))

; Dynamic variables
(defvar *in-export* nil)

; Utils

(defun shuffle (list)
  (let ((storage (make-array (length list) :adjustable nil :fill-pointer nil)))
    (dolist (item list)
      (push item (aref storage (random (length storage)))))
    (loop for i from 0 to (1- (length storage)) append (aref storage i))))

(defmacro random-dolist ((object list) &body code)
  `(dolist (,object (shuffle ,list)) ,@code)) 

(defun mapappend (function &rest lists)
  "maps elements in list and finally appends all resulted lists."
  (apply #'append (apply #'mapcar function lists)))

; Storable class
(defclass storable-class ()
  ((import-file :initform '("cl-ass.lisp") :accessor import-file)))

(defun slot-to-slot-definition (slot-defn)
  "Transforms slot definition object into list of definitions as in from defclass"
  (list :name (slot-definition-name slot-defn)
        :allocation (slot-definition-allocation slot-defn)
        :readers (slot-definition-readers slot-defn)
        :writers (slot-definition-writers slot-defn)
        :initform (slot-definition-initform slot-defn)
        :initargs (slot-definition-initargs slot-defn)
        :initfunction (slot-definition-initfunction slot-defn)))

; Agent
(defclass agent-class (storable-class) 
  ())

(defclass agent (agent-class) ())

(defun add-percept-slot (class percept-name)
  "Adds new slot to the class with name that of the percept"
  (check-type class symbol)
  (let ((slots (list (list :name percept-name
                           :readers (list percept-name)
                           :writers (list (list 'setf percept-name))))))
    (dolist (slot (class-direct-slots (find-class class)))
      (let ((slot-definition (slot-to-slot-definition slot)))
        (unless (eq (second slot-definition) percept-name)
          (push (slot-to-slot-definition slot)
                slots))))
    (clos:ensure-class class :direct-slots slots)))

(defgeneric agent-function (agent)
  (:documentation "Agent function"))

(defmethod agent-function-base ((agent agent) environment)
  "Base method for agent function. Will call all percepts and bind their value to the slots.
Afterwards, it will call agent function and call all actuators activated"
  (let ((percepts (percepts-of agent)))
    (dolist (percept percepts)
      (setf (slot-value agent percept) (funcall (percept-name percept) agent environment))))
  (let ((actuator-list (agent-function agent)))
    (dolist (actuator actuator-list)
      (funcall actuator agent environment))))

(defgeneric percepts-of (agent))
(defgeneric (setf percepts-of) (t agent))
(defgeneric actuators-of (agent))
(defgeneric (setf actuators-of) (t agent))

(defmacro defagent (name (&rest slot-definitions))
  "Generates new agent, with predefined slots and metaclass"
  `(defclass ,name (agent) 
     ((percepts :allocation :class :initform nil :accessor percepts-of)
      (actuators :allocation :class :initform nil :accessor actuators-of)
      ,@slot-definitions)))

(defun percept-name (percept)
  (intern (concatenate 'string (symbol-name percept) "-PERCEPT")))

(defmacro defpercept (name ((variable agent) e) &body body)
  "Creates new percept in from of method. Stores some metadata into agent class and
adds new slot to the agent"
  (let ((static-instance (make-instance agent)))
    (setf (percepts-of static-instance)
          (adjoin name (percepts-of static-instance)))
    (add-percept-slot agent name))
  `(defmethod ,(percept-name name) ((,variable ,agent) ,e) ,@body))

(defmacro defactuator (name ((variable agent) e) &body body)
  "Creates new percept in form of method. Also stores some metadata into agent class."
  (let ((static-instance (make-instance agent)))
    (setf (actuators-of static-instance)
          (adjoin name (actuators-of static-instance))))
  `(defmethod ,name ((,variable ,agent) ,e) ,@body))

; Environment
(defclass environment-class (storable-class) ())

(defclass environment (environment-class) ())

(defgeneric initialize-environment (environment simulation)
  (:documentation "Initializes environment for new use, can be called multiple times"))

(defmacro defenvironment (name (&rest slot-definitions))
  "Creates new environment class with correct metaclass"
  `(defclass ,name (environment) (,@slot-definitions)))

; Simulation
(defclass simulation-class (storable-class) ())

(defclass simulation (simulation-class) 
  ((environment :accessor environment)
   (agents :accessor agents :initform nil)))

(defgeneric environment-class (simulation))
(defgeneric agent-list (simulation))
(defgeneric agents (simulation))
(defgeneric (setf agents) (simulation list))

(defmethod generate-environment ((s simulation))
  "Creates environment, which is then initialized and set to simulation"
  (let ((e (make-instance (environment-class s))))
    (initialize-environment e s)
    (setf (environment s) e)))

(defmethod initialize-simulation ((s simulation))
  "This should be called before every new run of the simulation"
  (generate-environment s)
  (setf (agents s) nil)
  (dolist (agent-name (agent-list s))
    (push (make-instance agent-name)
          (agents s)))
  s)

(defmethod iterate ((s simulation) &optional (n 1))
  "Do one run of the simulation"
  (dotimes (x n)
    (random-dolist (agent (agents s))
      (agent-function-base agent (environment s)))))

(defmacro defsimulation (name (&rest slots) environment-class (&rest agent-list))
  `(defclass ,name (simulation) 
     ((environment-class :reader environment-class :initform ',environment-class)
      (agent-list :reader agent-list :initform ',agent-list)
      ,@slots)))

; Exporting function
(defmacro with-text-output-stream (stream &body body)
  `(let ((,stream (make-instance 'text-output-stream)))
     ,@body))

(defmacro with-array-stream ((s array) &body body)
  `(let ((,s (make-instance 'array-input-stream :array ,array)))
     ,@body))

(defun export-simulation (export-file &key simulation-instance (path "."))
  "Exports simulation to the file specified"
  (let ((*in-export* t))
    (with-open-file (output export-file :direction :output :if-exists :supersede)
      (let* ((all-classes (remove-system-classes (subclasses* (find-class 'storable-class))))
             (*standard-output* output)
             (include-files (build-includes all-classes path)))
      ; export include files
        (format t "; Exporting include files~%")
        (dolist (include include-files)
          (format t "; Exporting file \"~A\"~%" include)
          (block read-file
            (with-open-file (is include :direction :input)
              (loop 
               (let ((line (read-line is nil)))
                 (unless line
                   (return-from read-file))
                 (princ line) (terpri))))))
      ; export class definitions
        (format t "~%; Exporting class definitions~%")
        (dolist (class all-classes)
          (format t "; class <~A>" (class-name class))
          (display-defclass class)
          (terpri) (terpri))
      ; export methods
      ;(format t "~%; all generic functions")
        (let ((gfs (remove-duplicates
                    (loop for class in all-classes append 
                          (relevant-generic-functions class 
                                                      (find-class 'standard-object)
                                                      :elide-accessors-p t)))))
        ;(dolist (gf gfs)
        ;  (pprint (generate-defgeneric gf)))
          (format t "~%; all methods")
          (let ((methods (remove-duplicates 
                          (loop for gf in gfs append (loop for class in all-classes append (filter-irrelevant-methods gf class))))))
            (dolist (m methods)
              (unless (method-compiled-p m)
                (pprint (generate-defmethod m :show-body t))))))
      ; export state, if desired
        (when simulation-instance
          (format t "~%; Creating save state~%(defun deserialize-saved-state ()~%  (with-array-stream (is #(")
          (with-text-output-stream os 
            #+quicklisp(cl-store:store simulation-instance os)
            #-quicklisp(error "This requires quicklisp and cl-store loaded"))
          (format t "))~%       (cl-store:restore is)))"))))))
  
(defun remove-system-classes (classes)
  (remove-if (lambda (class)
               (member (class-name class) *system-classes*))
             classes))
 
(defun build-includes (classes path)
  (let (includes)
    (dolist (class classes)
      (dolist (include (import-file (make-instance class)))
        (push include includes)))
    (setf includes (ensure-first (remove-duplicates includes :test #'string=) "cl-ass.lisp" :test #'string=))
    (loop for include in includes collect (merge-pathnames include path))))

(defun ensure-first (list value &key (test #'eq))
  (if (not (member value list :test test))
      list
    (cons value (remove value list :test test))))

(defclass text-output-stream (stream:fundamental-binary-output-stream) ())

(defmethod stream:stream-write-byte ((is text-output-stream) integer)
  (format t "~A " integer)
  0)

(defclass array-input-stream (stream:fundamental-binary-input-stream)
  ((backend-array :initarg :array :reader backend-array)
   (current-position :initform 0 :accessor cp)))

(defmethod stream:stream-read-byte ((s array-input-stream))
  (if (>= (cp s) (length (backend-array s)))
      :eof
    (prog1
        (aref (backend-array s) (cp s))
      (incf (cp s)))))

; taken from The Art of Metaobject Protocol, chapter 2 pages 53-66, somewhat modified for class allocated information
(defun display-defclass (class)
  (pprint (generate-defclass class))
  (values))

(defun generate-defclass (class)
  `(defclass 
             ,(class-name class)
             ,(mapcar #'class-name (class-direct-superclasses class))
     ,(mapcar (lambda (slot) (generate-slot-specification slot class)) (class-direct-slots class))))

(defun generate-slot-specification (slot class)
  `(,(slot-definition-name slot)
    ,@(when (slot-definition-allocation slot)
        `(:allocation ,(slot-definition-allocation slot)))
    ,@(when (eq (slot-definition-allocation slot) :class)
        `(:initform (quote ,(slot-value (make-instance class) (slot-definition-name slot)))))
    ,@(when (and (slot-definition-initfunction slot) (not (eq :class (slot-definition-allocation slot))))
        `(:initform ,(slot-definition-initform slot)))
    ,@(when (slot-definition-initargs slot)
        (mapappend #'(lambda (initarg) `(:initarg ,initarg))
                   (slot-definition-initargs slot)))
    ,@(when (slot-definition-readers slot)
        (mapappend #'(lambda (reader) `(:reader ,reader))
                   (slot-definition-readers slot)))
    ,@(when (slot-definition-writers slot)
        (mapappend #'(lambda (writer) `(:writer ,writer))
                   (slot-definition-writers slot)))))

(defun subclasses* (class)
  (remove-duplicates 
   (cons class
         (mapappend #'subclasses*
                    (class-direct-subclasses class)))))

(defun all-generic-functions ()
  (remove-duplicates
   (mapappend #'class-direct-generic-functions
              (subclasses* (find-class 't)))))

(defun class-direct-generic-functions (class)
  (remove-duplicates
   (mapcar #'method-generic-function 
           (class-direct-methods class))))

(defun relevant-generic-functions (class ceiling &key elide-accessors-p)
  (remove-duplicates
   (mapcar #'method-generic-function
           (remove-if #'(lambda (m)
                          (and elide-accessors-p
                               (or (reader-method-p m)
                                   (writer-method-p m))))
                      (mapappend #'class-direct-methods
                                 (set-difference (class-precedence-list class)
                                                 (class-precedence-list ceiling)))))))
(defun reader-method-p (method)
  (let ((specializers (method-specializers method)))
    (and (= (length specializers) 1)
         (member (generic-function-name (method-generic-function method))
                 (mapappend #'slot-definition-readers 
                            (class-direct-slots (car specializers)))
                 :test #'equal))))

(defun writer-method-p (method)
  (let ((specializers (method-specializers method)))
    (and (= (length specializers) 2)
         (member (generic-function-name (method-generic-function method))
                 (mapappend #'slot-definition-writers 
                            (class-direct-slots (cadr specializers)))
                 :test #'equal))))

(defun generate-defgeneric (gf)
  `(defgeneric ,(generic-function-name gf)
       ,(generic-function-lambda-list gf)))

(defun generate-defmethod (method &key show-body)
  `(defmethod ,(generic-function-name (method-generic-function method))
              ,@(method-qualifiers method)
     ,(generate-specialized-arglist method)
     ,@(when show-body (method-body method))))

(defun generate-specialized-arglist (method)
  (let* ((specializers (method-specializers method))
         (lambda-list (method-lambda-list method))
         (number-required (length specializers)))
    (append (mapcar #'(lambda (arg class)
                        (if (eq class (find-class 't))
                            arg
                          `(,arg ,(class-name class))))
                    (subseq lambda-list 0 number-required)
                    specializers)
            (subseq lambda-list number-required))))

; End of taken classes from the Art of Metaobject Protocol

(defun method-body (method)
  "Returns body of underlined function or nil if compiled"
  (let ((fnccode (function-lambda-expression (method-function method))))
    (when fnccode
      (cddr (second (fourth (fourth (third (third (fourth fnccode))))))))))

(defun filter-irrelevant-methods (gf class)
  (remove-if-not (lambda (method)
                   (member class (method-specializers method)))        
                 (generic-function-methods gf)))

(defun method-compiled-p (method)
  (compiled-function-p (method-function method)))
